home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Software Vault: The Gold Collection
/
Software Vault - The Gold Collection (American Databankers) (1993).ISO
/
cdr48
/
entrt101.zip
/
ENTERIT.PAS
< prev
Wrap
Pascal/Delphi Source File
|
1993-04-22
|
24KB
|
597 lines
{$A+,B-,D-,E-,F-,I+,N-,O-,R+,S-,V+}
(****************************************************************************)
(* ENTERIT.PAS - Data-entry unit. *)
(* version 1.01 (March 10, 1992) *)
(* TP required: 6.0 *)
(* by Guy McLoughlin *)
(* Released to the public domain. *)
(****************************************************************************)
unit EnterIt; (* Data-entry field unit. *)
(****************************************************************************)
interface
(****************************************************************************)
uses
Qwriter;
(****************************************************************************)
(* Unit Routines *)
(****************************************************************************)
(* Set ErrorMessage X-Y position, and color. *)
procedure InitErrorMess(Xaxis, Yaxis : byte; Cattr : word);
(* Get a string from User. *)
function EnterString(FieldWidth, (* Width of entry-field. *)
Xaxis, (* Where to place this *)
Yaxis : byte; (* entry-field. *)
Cattr : word) : VidString; (* Field-attribute. *)
(* Format a string with commas, expanded to Width size. *)
function Comma(InString : VidString; Width : byte) : VidString;
(* Get a short sized number from User. *)
function EnterShort(Min, Max : shortint; (* Min, Max shortint values.*)
FieldWidth, (* Width of entry-field. *)
Xaxis, (* Where to place this *)
Yaxis : byte; (* entry-field. *)
Cattr : word) : shortint; (* Field-attribute. *)
(* Get a byte sized number from User. *)
function EnterByte(Min, Max, (* Min, Max byte values. *)
FieldWidth, (* Width of entry-field. *)
Xaxis, (* Where to place this *)
Yaxis : byte; (* entry-field. *)
Cattr : word) : byte; (* Field Field-attribute. *)
(* Get a integer sized number from User. *)
function EnterInt(Min, Max : integer; (* Min, Max integer values. *)
FieldWidth, (* Width of entry-field. *)
Xaxis, (* Where to place this *)
Yaxis : byte; (* entry-field. *)
Cattr : word) : integer; (* Field-attribute. *)
(* Get a word sized number from User. *)
function EnterWord(Min, Max : word; (* Min, Max word values. *)
FieldWidth, (* Width of entry-field. *)
Xaxis, (* Where to place this *)
Yaxis : byte; (* entry-field. *)
Cattr : word) : word; (* Field Field-attribute. *)
(* Get a long sized number from User. *)
function EnterLong(Min, Max : longint; (* Min, Max longint values. *)
FieldWidth, (* Width of entry-field. *)
Xaxis, (* Where to place this *)
Yaxis : byte; (* entry-field. *)
Cattr : word) : longint; (* Field-attribute. *)
(* Get a Real sized number from User. *)
function EnterReal(Min, Max : real; (* Min, Max Real values. *)
DecNum, (* Format with N decimals. *)
FieldWidth, (* Width of entry-field. *)
Xaxis, (* Where to place this *)
Yaxis : byte; (* entry-field. *)
Cattr : word) : real; (* Field-attribute. *)
(****************************************************************************)
implementation
(****************************************************************************)
type (* Enumerated entry data-types. *)
EntryType = (Eshortint, Ebyte, Einteger, Eword, Elongint, Estring);
const (* One blank space. *)
SpaceChar = #32;
(* Sets of valid entry characters, by data-type. *)
ShortSet = ['+', '-', '0'..'9']; (* Valid chars for shortints *)
ByteSet = ['+', '0'..'9']; (* Valid chars for bytes. *)
WordSet = [',','0'..'9']; (* Valid chars for Words. *)
RealSet = ['+'..'-', '.', '0'..'9']; (* Valid chars for Reals. *)
StringSet = [' '..'}']; (* Valid chars for Strings. *)
ErrorBlank = ' ';
var
ErrorX, (* Xaxis for ErrorMessage. *)
ErrorY, (* Yaxis for ErrorMessage. *)
ErrorAttr : word; (* Error message attribute. *)
(* String used to clear entry-field. *)
BlankString : VidString;
(* Set ErrorMessage X-Y position, and color. *)
procedure InitErrorMess(Xaxis, Yaxis : byte; Cattr : word);
begin
ErrorX := Xaxis;
ErrorY := Yaxis;
ErrorAttr := Cattr
end;
(* Display Error-message. *)
procedure ErrorMessage(MsgNum : byte);
begin
(* Make a beep. *)
Beep;
(* Display error-message. *)
case MsgNum of
1 : QWrite(' Invalid Number format!!! ', ErrorX, ErrorY,
ErrorAttr);
2 : QWrite(' Number is too Small!!! ', ErrorX, ErrorY,
ErrorAttr);
3 : QWrite(' Number is too Big!!! ', ErrorX, ErrorY,
ErrorAttr)
end;
(* Wait for any key to be pressed. *)
Pause(AnyKey);
(* Clear the error-message. *)
QWrite(ErrorBlank, ErrorX, ErrorY, NormAttr)
end;
(* Format a string with commas, expanded to Width size. *)
function Comma(InString : VidString; Width : byte) : VidString;
var
SignPos : byte; NumSigned : boolean absolute SignPos;
SignChar : char;
Index : byte;
TempString : string;
begin
TempString := InString;
(* Delete all blank spaces. *)
while (pos(' ', TempString) <> 0) do
delete(TempString, pos(' ', TempString), 1);
(* Check if number string is negative signed. *)
SignPos := pos('-', TempString);
(* If number string is negative, record sign and delete. *)
if NumSigned then
begin
SignChar := '-';
delete(TempString, SignPos, 1)
end
(* Else, the number string is not negative signed. *)
else
begin
(* Check number string is positive signed. *)
SignPos := pos('+', TempString);
(* If number string is signed, record sign, then delete. *)
if NumSigned then
begin
SignChar := '+';
delete(TempString, SignPos, 1)
end
end;
(* Check for a decimal point. *)
Index := pos('.', TempString);
if (Index <> 0) then
dec(Index, 1)
else
Index := length(TempString);
(* Insert commas in appropriate spots. *)
while (Index > 3) do
begin
dec(Index, 3);
insert(',', TempString, (Index + 1))
end;
(* If number string was signed, add the sign back. *)
if NumSigned then
TempString := SignChar + TempString;
(* Pad the number string with blanks if neccessary. *)
while (length(TempString) < Width) do
TempString := ' ' + TempString;
Comma := TempString
end;
(* Internal unit string function. *)
function GetString (Ntype : EntryType;
FieldWidth,
Xaxis,
Yaxis : byte;
Cattr : word) : VidString;
var
TempString : VidString;
KeyChoice : word;
KeyChar : char absolute KeyChoice;
KeyOK : boolean;
EntryIndex : word;
begin
(* Clear the temporary string buffer. *)
fillchar(TempString, sizeof(TempString), 0);
(* Limit the maximum string size. *)
if (FieldWidth > Columns) then
FieldWidth := Columns;
(* Set the length of the "blank" string. *)
BlankString[0] := chr(FieldWidth);
(* Initialize variables. *)
EntryIndex := 1;
TempString := '';
(* Blank out the entry-field area. *)
QWrite(BlankString, Xaxis, Yaxis, Cattr);
(* Clear the key-buffer. *)
ClearKeyBuff;
repeat (* Repeat..Until a number has been entered. *)
(* Reset boolean. *)
KeyOK := false;
(* Read the User's key press. *)
KeyChoice := ReadKeyWord;
(* Decide how to handle the key press. *)
case Ntype of
Eshortint,
Einteger,
Elongint : if (KeyChar in ShortSet) then
KeyOK := true;
Ebyte : if (KeyChar in ByteSet) then
KeyOK := true;
Eword : if (KeyChar in WordSet) then
KeyOK := true;
Estring : if (KeyChar in StringSet) then
KeyOK := true
end;
(* If the key entered is OK, then... *)
if KeyOK and (EntryIndex <= FieldWidth) then
begin
inc(EntryIndex, 1);
TempString := TempString + KeyChar;
QWrite(TempString,
((Xaxis + FieldWidth) - length(TempString)),
Yaxis, Cattr)
end
(* Else, the key entered is not OK... *)
else
if ((KeyChoice = BackSpaceKey)
or (KeyChoice = RightArrowKey)
or (KeyChoice = DeleteKey))
and (EntryIndex > 1) then
begin
dec(EntryIndex, 1);
delete(TempString, length(TempString), 1);
QWrite((SpaceChar + TempString),
((Xaxis + FieldWidth) - (length(TempString) + 1)),
Yaxis, Cattr)
end
(* Repeat..Until a number string is entered. *)
until (TempString <> '') and (KeyChoice = EnterKey);
GetString := TempString
end;
(* Get a string from User. *)
function EnterString(FieldWidth, (* Width of entry-field. *)
Xaxis, (* Where to place this *)
Yaxis : byte; (* entry-field. *)
Cattr : word) : VidString; (* Field-attribute. *)
begin
EnterString := GetString(Estring, FieldWidth, Xaxis, Yaxis, Cattr)
end;
(* Get a short sized number. *)
function EnterShort(Min, Max : shortint; (* Min, Max shortint values.*)
FieldWidth, (* Width of entry-field. *)
Xaxis, (* Where to place this *)
Yaxis : byte; (* entry-field. *)
Cattr : word) : shortint; (* Field-attribute. *)
var
TempShort : longint;
Result : integer;
Error : boolean absolute Result;
begin
(* Repeat until a valid number is entered. *)
repeat
val(GetString(Eshortint, FieldWidth, Xaxis, Yaxis, Cattr),
TempShort, Result);
(* If string is not a valid number, then... *)
if Error then
ErrorMessage(1)
else
(* If the number entered is too small, then... *)
if (TempShort < Min) then
begin
Error := true;
ErrorMessage(2)
end
else
(* If the number entered is too big, then... *)
if (TempShort > Max) then
begin
Error := true;
ErrorMessage(3)
end
until (Error = false);
EnterShort := shortint(TempShort)
end;
(* Get a byte sized number. *)
function EnterByte(Min, Max, (* Min, Max byte values. *)
FieldWidth, (* Width of entry-field. *)
Xaxis, (* Where to place this *)
Yaxis : byte; (* entry-field. *)
Cattr : word) : byte; (* Field Field-attribute. *)
var
TempByte : longint;
Result : integer;
Error : boolean absolute Result;
begin
(* Repeat until a valid number is entered. *)
repeat
val(GetString(Ebyte, FieldWidth, Xaxis, Yaxis, Cattr),
TempByte, Result);
(* If string is not a valid number, then... *)
if Error then
ErrorMessage(1)
else
(* If the number entered is too small, then... *)
if (TempByte < Min) then
begin
Error := true;
ErrorMessage(2)
end
else
(* If the number entered is too big, then... *)
if (TempByte > Max) then
begin
Error := true;
ErrorMessage(3)
end
until (Error = false);
EnterByte := byte(TempByte)
end;
(* Get a integer sized number. *)
function EnterInt(Min, Max : integer; (* Min, Max integer values. *)
FieldWidth, (* Width of entry-field. *)
Xaxis, (* Where to place this *)
Yaxis : byte; (* entry-field. *)
Cattr : word) : integer; (* Field-attribute. *)
var
TempInt : longint;
Result : integer;
Error : boolean absolute Result;
begin
(* Repeat until a valid number is entered. *)
repeat
val(GetString(Einteger, FieldWidth, Xaxis, Yaxis, Cattr),
TempInt, Result);
(* If string is not a valid number, then... *)
if Error then
ErrorMessage(1)
else
(* If the number entered is too small, then... *)
if (TempInt < Min) then
begin
Error := true;
ErrorMessage(2)
end
else
(* If the number entered is too big, then... *)
if (TempInt > Max) then
begin
Error := true;
ErrorMessage(3)
end
until (Error = false);
EnterInt := integer(TempInt)
end;
(* Get a word sized number. *)
function EnterWord(Min, Max : word; (* Min, Max word values. *)
FieldWidth, (* Width of entry-field. *)
Xaxis, (* Where to place this *)
Yaxis : byte; (* entry-field. *)
Cattr : word) : word; (* Field Field-attribute. *)
var
TempWord : longint;
Result : integer;
Error : boolean absolute Result;
begin
(* Repeat until a valid number is entered. *)
repeat
val(GetString(Eword, FieldWidth, Xaxis, Yaxis, Cattr),
TempWord, Result);
(* If string is not a valid number, then... *)
if Error then
ErrorMessage(1)
else
(* If the number entered is too small, then... *)
if (TempWord < Min) then
begin
Error := true;
ErrorMessage(2)
end
else
(* If the number entered is too big, then... *)
if (TempWord > Max) then
begin
Error := true;
ErrorMessage(3)
end
until (Error = false);
EnterWord := word(TempWord)
end;
(* Get a long sized number. *)
function EnterLong(Min, Max : longint; (* Min, Max longint values. *)
FieldWidth, (* Width of entry-field. *)
Xaxis, (* Where to place this *)
Yaxis : byte; (* entry-field. *)
Cattr : word) : longint; (* Field-attribute. *)
var
TempLong : longint;
Result : integer; Error : boolean absolute Result;
begin
(* Repeat until a valid number is entered. *)
repeat
val(GetString(Elongint, FieldWidth, Xaxis, Yaxis, Cattr),
TempLong, Result);
(* If string is not a valid number, then... *)
if Error then
ErrorMessage(1)
else
(* If the number entered is too small, then... *)
if (TempLong < Min) then
begin
Error := true;
ErrorMessage(2)
end
else
(* If the number entered is too big, then... *)
if (TempLong > Max) then
begin
Error := true;
ErrorMessage(3)
end
until (Error = false);
EnterLong := TempLong
end;
(* Get a Real sized number. *)
function EnterReal(Min, Max : real; (* Min, Max Real values. *)
DecNum, (* Format with N decimals. *)
FieldWidth, (* Width of entry-field. *)
Xaxis, (* Where to place this *)
Yaxis : byte; (* entry-field. *)
Cattr : word) : real; (* Field-attribute. *)
var
TempString : VidString;
KeyChoice : word; KeyChar : char absolute KeyChoice;
TempReal : real;
DotPos : byte; DotEntered : boolean absolute DotPos;
EntryIndex : byte;
Result : integer; Error : boolean absolute Result;
begin
fillchar(TempString, sizeof(TempString), 0);
if (FieldWidth > Columns) then
FieldWidth := Columns;
BlankString[0] := chr(FieldWidth);
(* Repeat until a valid number is entered. *)
repeat
EntryIndex := 1;
TempString := '';
DotPos := 0;
QWrite(BlankString, Xaxis, Yaxis, Cattr);
ClearKeyBuff;
repeat
KeyChoice := ReadKeyWord;
if (KeyChar in RealSet)
and (EntryIndex <= FieldWidth) then
begin
if DotEntered then
begin
if (KeyChar <> #46)
and (length(TempString) < (DotPos + DecNum)) then
begin
TempString := TempString + KeyChar;
inc(EntryIndex, 1);
QWrite(TempString, (Xaxis + FieldWidth - length(TempString)),
Yaxis, Cattr)
end
end
else
begin
if (KeyChar = #46) then
DotPos := EntryIndex;
TempString := TempString + KeyChar;
inc(EntryIndex, 1);
QWrite(TempString, (Xaxis + FieldWidth - length(TempString)),
Yaxis, Cattr)
end;
end
else
if (KeyChoice = BackSpaceKey)
or (KeyChoice = RightArrowKey)
or (KeyChoice = DeleteKey) then
begin
if (EntryIndex > 1) then
begin
dec(EntryIndex);
if (TempString[EntryIndex] = #46) then
DotPos := 0;
delete(TempString, length(TempString), 1);
QWrite((SpaceChar + TempString),
(Xaxis + FieldWidth - (length(TempString) + 1)),
Yaxis, Cattr)
end
end;
if (DotEntered) and (length(TempString) = 1) then
KeyChoice := 0
until (KeyChoice = EnterKey);
while (pos(',', TempString) <> 0) do
delete(TempString, pos(',', TempString), 1);
val(TempString, TempReal, Result);
(* If string is not a valid number, then... *)
if Error then
ErrorMessage(1)
else
(* If the number entered is too small, then... *)
if (TempReal < Min) then
begin
Error := true;
ErrorMessage(2)
end
else
(* If the number entered is too big, then... *)
if (TempReal > Max) then
begin
Error := true;
ErrorMessage(3)
end
until (Error = false);
EnterReal := TempReal
end;
BEGIN
(* Set error message defaults. *)
InitErrorMess(1, 1, RevAttr);
(* Clear the "BlankString" variable. *)
fillchar(BlankString, sizeof(VidString), SpaceChar)
END.